;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; application-independant utilities

(defmacro debug-noop (&rest args))

(defun as-bool (v)
  (if v "true" "false"))

(defun cdr-eql (a b)
  (eql (cdr a) (cdr b)))

(defun cdr< (a b)
  (< (cdr a) (cdr b)))

(defun mappend (fn &rest lsts)
  "non-destructive version of mapcan"
  (apply #'append (apply #'mapcar fn lsts)))

(defmacro newline () "
")

(defun join-to-string (list &optional sep)
  (with-output-to-string (stream)
    (dolist (item list) 
      (princ item stream)
      (when sep
        (princ sep stream)))))

(defmacro while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))


(defmacro test2 (test)
  "multi-value test, for [result,success] style return values, such as
  gethash returns."
  (let ((var (gensym))
        (yn  (gensym)))
    `(multiple-value-bind (,var ,yn) ,test
       (or ,var ,yn))))

(let ((g (gensym)))
  (defun read2 (&optional (str *standard-input*))
    "read from given stream, returning multi-values [sexp, success]" 
    (let ((val (read str nil g)))
      (unless (equal val g) (values val t)))))

(defmacro a/when2 (var test &body body)
  "anaphoric when, evaluating body only if multi-value condition is
  true, with multi-value conditional resembling [value, exists] as in the
  return value of gethash."
  (let ((win (gensym)))
    `(multiple-value-bind (,var ,win) ,test
       (when (or ,var ,win)
         ,@body))))

(defmacro a/if2 (var test &optional then else)
  "anaphoric if, with multi-value conditional of [value, exists], as
  in the return of gethash.  Binds value to 'var' (if it exists)."
  (let ((win (gensym)))
    `(multiple-value-bind (,var ,win) ,test
       (if (or ,var ,win) ,then ,else))))

(defmacro a/while2 (var test &body body)
  "anaphoric while, with multi-value conditional of [value, exists],
  as in the return of gethash.  Binds value to 'var' (if it exists)."
  (let ((flag (gensym)))
    `(let ((,flag t))
       (while ,flag
         (a/if2 ,var ,test
               (progn ,@body)
               (setq ,flag nil))))))

(defmacro do-file (var filename &body body)
  "anaphoric iteration over a stream, evaluating body with 
  current s-expression bound to 'var'."
  (let ((str (gensym)))
    `(with-open-file (,str ,filename)
       (a/while2 ,var (read2 ,str)
         ,@body))))

(defun semi-portable-argv ()
  "semi-portable way to access argv"
  (or 
   #+SBCL sb-ext:*posix-argv*  
   #+LISPWORKS system:*line-arguments-list*
   #+CMU extensions:*command-line-words*
   #+CLISP EXT:*ARGS*
   nil))

(defun to-item (thing)
  (if (listp thing) 
      (car thing)
      thing))

(defun to-list (thing)
  (if (listp thing) 
      thing
      (list thing)))

(defun copy-until (pred list)
  "return a new list containing each list element e until (pred e) is
   true" 
  (let ((result '()))
    (dolist (e list)
      (when (funcall pred e)
        (return))
      (push e result))
    (nreverse result)))

(defun flatten-list-to-string (list &optional (sep ""))
  "convert a list of things into a single string containing only the
   elements separated by a space."
  ;; this builds a looping format string that selects one of 3 cases,
  ;; (0, 1, or >1).  After building the format string, if sep is "XX"
  ;; it may look like this: "~{~#[~;~a~:;~aXX~]~}

  (let ((format-string (format nil "~~{~~#[~~;~~A~~:;~~A~A~~]~~}" sep)))
    ;;format deciphered: 
    ;;[iteraton/each element of list]
    (format nil format-string list)))


(defun has-duplicates-p (list &key (test 'eql))
  "determines if list has duplicates."
  (let ((hash (make-hash-table :test test)))
    (dolist (item list nil)
      (a/if2 val (gethash item hash)
             (return (values t (list item val)))
             (setf (gethash item hash) t)))))

(defun has-duplicates-sorted-p (list eql-compare)
  "for a sorted list, we can more easily check for dupes 
than by using a hash."
  (let ((prev (car list)))
    (dolist (item (cdr list))
      (when (funcall eql-compare prev item)
        (return (values t (list prev item))))
      (setf prev item))))
    
;; todo: should use lisp pathname objects
(defun basename (filename)
  "strips path from filename"
  (let ((idx (search "/" filename :from-end t)))
    (if (null idx)
        filename
      (subseq filename (1+ idx)))))


;; =======================================================


(defparameter *use-char-type* nil)

(defparameter *eg-sections* '())
(defparameter *eg-values* (make-hash-table :test #'equal))
(defparameter *compatibility-interface* nil)

; when evaluating a section, its current context will update this
; variable to make it more easily accessible
(defparameter *cur-section-context* nil)

(defvar filename-suffix)
(defvar namespace)

(defun dump-hash (&optional (hash *eg-values*))
  ;;format deciphered: 
  ;;[key][tab]=>[value][newline]
  (maphash (lambda (k v) (format t "~A~t=>~A~%" k v)) hash))


(defmacro def-enum (name enumerator-info)
  `(progn
     (setf (gethash :enum *eg-values*) (list ,name ',enumerator-info))))
     
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; defexpand is similar to (defun ...) except it associates the lambda
;; with the symbol in the symbol's property-list, not in the symbol's
;; function "slot".  This allows for user-supplied values to reside
;; there, and this is found as a default.
(defmacro defexpand (name parms &body body)
  `(progn (defparameter ,name '())
          (setf (get ',name 'default-function)  
                #'(lambda ,parms 
                    ,@body))))





(defun eg-call (sym is-optional? default-retval &rest args)
  (let ((default-func (get sym 'default-function)))
    (cond 
      ;; Did user defun symbol?  If so, invoke it.
      ((fboundp sym) (apply (symbol-function sym) args))

      ;; User didn't defun the symbol.  Did user provide a value
      ;; instead?  The value may be usually anything, but if it's a
      ;; lambda we'll invoke it.  Otherwise we just return the value.
      ;; However, if arguments are provided, that means a function is
      ;; expected to be called, and in that case the user may only
      ;; bind a lambda to the symbol.  (Or defun it.)
      ((and (boundp sym) (not (null (symbol-value sym))))
       (let ((val (symbol-value sym)))
         (if (functionp val) 
             (apply val args)
             (if (null args)
                 (if val val "")
                 (error (format 
                         nil "the key ~A requires an arity ~A function."
                         sym (length args)))))))

      ;; No user values at all.  Is there a default implementation?
      ((not (null default-func)) (apply default-func args))
      
      ;; No default function.  Is it optional?  If so then we don't fail
      (is-optional? default-retval)
      
      ;; Nothing associated at all, and it's not optional. Thus it's
      ;; an error.
      (t (error (format 
                 nil 
                 "expecting something to be associated with symbol ~A~%"
                 (symbol-name sym)))))))


;; call function named by sym, signal error if it is not
(defmacro %% (sym &rest args)
  `(eg-call ',sym nil nil ,@args))


;; call function named by sym if it's defined, return nil if it's not
(defmacro ?? (sym &optional (default-retval "") &rest args)
  `(eg-call ',sym t ,default-retval ,@args))

(defun to-keyword (symbol)
  (intern (symbol-name symbol) (find-package "KEYWORD")))

(defun maxlen (strings)
  (reduce (lambda (curmax string)
            (max curmax (length string)))
          strings
          :initial-value 0))

(defun list-into-hash (list hash)
  "inserts pairs from the list into the hash.  Note: not an assoc
  list, but a regular list, with alternating key/value elements."
  (if (null list)
      hash
    (let ((key (car list))
          (val (cadr list)))
      (setf (gethash key hash) val)
      (list-into-hash (cddr list) hash))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; enumgen-specific utilities

(defun keyword-lookup (key list)
  "returns the sublist of elements following keyword 'key' up to (but
  not including) the next keyword in the list.  2nd return value
  indicates success or failure of finding the keyword."
  (let ((value (member key list)))
    (if value
        (values (copy-until #'keywordp (cdr value)) t)
        (values nil nil))))
    
    
(defun keyword-lookup-single (key list &optional optional?)
  "returns a single item given by list.  Signals an error if entry has
  more than one value."
    (a/if2 entry (keyword-lookup key list)
           (cond ((atom entry) entry)
                 ((listp entry) 
                  (if (null (cdr entry))
                      (car entry) ; success, there was only 1 item
                      (error (format 
                              nil
                              "Expected 1 entry for ~A, got ~A.  2nd
  entry begins:~%~A"
                              key
                              (length entry)
                              (cadr entry))))))
           (unless optional?
             (error (format nil "Unable to find non-optional value ~A"
                            key)))))
           

(defun getvar (name)
  (gethash name *eg-values*))

(defun context-lookup (name context)
  (gethash name context))

(defmacro resolve (key args)
  "find value for keyword, by using user-provided values, and if those
  are not found, then looking for keywords in the user-input (spec)
  file."
  `(or (?? ,key nil)
       (car (keyword-lookup ,(to-keyword key) ,args))))

; args is a list of alternating name/value(s), where each name is a
; KEYWORD, and its values follow until the next keyword.
(defun make-filename (args)
  (let* ((prefix (to-item (resolve filename-prefix args)))
         (base   (to-item (resolve filename-base args)))
         (suffix (to-item (resolve filename-suffix args)))
         (extension (keyword-lookup-single :filename-extension args)))

    (when (null base) (setf base (%% eg-class-name)))
    (values prefix base suffix extension)))
    
(defun defsection (name &rest args)
  "each section in a .def file specifies an output file.  The main three
sections are for the hpp, ipp, and cpp files to be generated.  A section
has three parts, a name, an extension, and a function to generate the 
code, stored in *eg-section*" 
  (multiple-value-bind (pre base suf ext) (make-filename args)
    (let* ((code (keyword-lookup-single :code args))
           (fullname (concatenate 'string pre base suf "." ext))
           (section-context (make-hash-table :test #'equal)))
      ;; section context.
      (setf (gethash :filename-prefix    
                     section-context) pre)
      (setf (gethash :filename-base      
                     section-context) base)
      (setf (gethash :filename-suffix    
                     section-context) suf)
      (setf (gethash :filename-extension 
                     section-context) ext)
      (setf (gethash :filename-full      
                     section-context) fullname)
      (let ((func (lambda ()
                   ;; first thing, update the global access var to our context
                   (setf *cur-section-context* section-context)

                   ;; set all args into the section context hash for
                   ;; easier access by users
                   (list-into-hash args section-context)

                   (format t "  ~A~%" fullname)
                   ;; make values available to the .def file in the
                   (with-open-file (outfile 
                                    fullname
                                    :direction :output 
                                    :if-exists :supersede)
                     (mapc #'(lambda (code-frag)
                               (format outfile "~A" (eval code-frag)))
                           code)))))
        (push (list name ext func section-context) *eg-sections*)))))
    
(defun section-name (sec)      (first sec))
(defun section-extension (sec) (second sec))
(defun section-function (sec)  (third sec))
(defun section-context (sec)   (fourth sec))

(defun enumerator-name (e)
  (car e))


;; =======================================================
;;
;; "starting point" of enumgen application
;;
;; =======================================================
(defun main (pwd input-filename &optional (def-file "./enumgen.def"))
  (setf *print-pretty* nil)
  (setf (gethash :input-filename *eg-values*) input-filename)
  (setf (gethash :def-filename   *eg-values*) def-file)
  (setf (gethash :base-filename  *eg-values*) (basename input-filename))
  (setf (gethash :enumgen-path   *eg-values*) pwd)
  
  ;; iterate over every s-expression in file named by input-filename,
  ;; evaluating it.  This processes the user's input file as source
  ;; code, and bails on any errors.  The code in input-filename is
  ;; first and foremost expected to define an enum via def-enum,
  ;; though arbitrary other code is ok.
  (do-file sexp input-filename
           (handler-case 
               (progn 
                 (eval sexp))
             (condition (c) 
               (progn(format t "Error: ~A~%...while evaluating code: ~A~%"
                      c sexp)
                     (exit 1)))))
  (validate)
  
  (format t "~%loading def file:~%")
  (load def-file)
  
  (?? pre-generate-hook)

  ;; For every section (created via (defsection ...) in the input,
  ;; generate the source file it describes.  (As the sections were
  ;; pushed onto the list, we want to process the list in reverse
  ;; order to get the same order as they appear in the .def file.)
  (format t "~%generating output:~%")
  (mapc (lambda (sec) (funcall (section-function sec)))
        (nreverse *eg-sections*))
  'Done)


(defun validate ()
  "perform post (in-memory) generation of enum.  When called, we have enough
context to do all validations."
  (ensure-no-two-primary-names-have-duplicate-values)
  (ensure-exactly-one-invalid-value))


(defun build-full-nvpair-list (&optional include-invalid)
  "builds a list of pairs, with car being the 'symbol' and the cdr the (numeric) value, for all entries in enum"
  (let ((full-result
         (mapcar #'cons
                 (%% enum-symbols)
                 (%% enum-values-full))))
    (if include-invalid 
        full-result
      (remove-if #'(lambda (x) 
                     (string= (car x) (%% enum-invalid-value)))
                 full-result))))

(defun build-nodupe-nvpair-list(&optional include-invalid)
  "all name-value pairs without any duplicates.  Does not
include the INVALID entry by default."
  (remove-duplicates (build-full-nvpair-list include-invalid)
                     :test #'cdr-eql
                     :from-end t))


(defun build-priname-nvpair-list ()
  "builds a list of pairs, with car being an explicitly named primary
name, and the value being the integral enumerator value.  Note: This
only includes names with a :primary-name indicator in the spec file."
  ;; example: (("a" . 1) ("b" . 2) ("c" . 3))
  (mappend (lambda (n v)
             (when n
               (list (cons n v))))
           (mapcar (lambda (enumerator)
                     (keyword-lookup-single 
                      :primary-name 
                      enumerator 
                      'optional))
                   (%% enumerators))
           (%% enum-values-full)))


(defun ensure-no-two-primary-names-have-duplicate-values ()
  "for any two EXPLICITLY specified primary names, check that 
they don't have the same value."

  (let ((nvpairs (build-priname-nvpair-list)))
    (multiple-value-bind 
        (has-dupes? dupes-found) 
        (has-duplicates-sorted-p (sort nvpairs #'cdr<)
                                 #'cdr-eql)
      (when has-dupes? 
        (error (format 
         nil 
         "Cannot specify multiple primary names with equal values: ~A~%"
         dupes-found))))))
      
    

(defun ensure-exactly-one-invalid-value ()
  (let ((c (count-if (lambda (e)
                       (string= (%% enum-invalid-value)
                                (enumerator-name e)))
                     (%% enumerators))))
    (unless (= 1 c)
      (error "Exactly one INVALID_ value expected, got ~A" c))))



;; =======================================================
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; functions used by the def file and user spec file

(defexpand cur-context-lookup (name)
  (context-lookup name *cur-section-context*))

(defexpand global-lookup (name)
  (getvar name))


(defexpand eg-class-name ()
  (car (getvar :enum)))


(defexpand enum-symbols ()
  "returns a list of all the enumerators"
  (mapcar #'to-item (%% enumerators)))


(defexpand enumerators ()
  "returns a list of lists, each of which completely describes an
  enumerator.  The length of the outer list is exactly the number of
  enumerators in the enum."
  (cadr (getvar :enum)))

(defexpand enum-values ()
  "[:value] return a list of numeric values with a 1-to-1
  correspondence to the enumerator symbols.  For default values, entry
  is nil, otherwise it's the value given in the spec file."
  (mapcar (lambda (enumerator)
            (and (listp enumerator)
                 (eval (keyword-lookup-single :value enumerator 'optional))))
          (%% enumerators)))

(defexpand enum-values-full ()
  "[:value] return a list of numeric values with a 1-to-1
  correspondence to the enumerator symbols.  For default values, entry
  is 'prev' value+1, otherwise it's the value given in the spec file."
  (let ((prev -1)
        (result '()))
    (dolist (v (%% enum-values))
      (let ((cur (or v (1+ prev))))
        (push cur result)
        (setf prev cur)))
    (nreverse result)))
      
(defexpand enum-symbols-for-unique-values()
  "[:value] return a list of *all* symbols with unique values from the
enum, whether it was specified explicitly or got the next value is
irrelevant.  Does NOT include INVALID_"
  (mapcar #'car (build-nodupe-nvpair-list)))

(defexpand enum-comments ()
  "[:comment] return a list of comments, one list per enumerator.  nil
  when not specified."
  (mapcar (lambda (enumerator)
            (keyword-lookup-single :comment enumerator 'optional))
          (%% enumerators)))

(defexpand enum-decl-body ()
  "generates a string to declare enumerators and their optional values
   and optional comments"
  ;; note: the lists returned from enum-{symbols,values,comments} are
  ;; all the same length, with nil values for value or comments when
  ;; not specified.
  (let* ((enum-symbols  (%% enum-symbols))
         (enum-values   (%% enum-values))
         (remain (length enum-symbols)))
    (flatten-list-to-string
     (mapcar (lambda (sym val)
               (decf remain)
               ;;format deciphered: 
               ;; [newline][indent 4 sp][enumname][optional '= value']
               ;; [opt-comma iff remain > 0]   [optional comment]
               (format nil "~%~4t~A~@[ = ~A~]~[~:;,~]" sym val remain))
             enum-symbols
             enum-values))))

;; the name is the string that is used when doing the string->enumgen
;; conversion 
(defexpand enum-primary-names ()
  "[:primary-name] the main string representation for each enum.  When
  not present, defaults to the enumerator's spelling."
  (mapcar (lambda (enumerator)
            (or (keyword-lookup-single :primary-name enumerator 'optional)
                (enumerator-name enumerator)))
          (%% enumerators)))

(defexpand enum-aliases ()
  "[:alias] the alternate string spellings for each enum."
  (mapcar (lambda (enumerator)
            (keyword-lookup :alias enumerator))
          (%% enumerators)))


(defun append-comment (decl-str col comment)
  (cond ((null comment) decl-str)
        (t (format nil "~A~VT// ~A" decl-str col comment))))


(defexpand enum-obj-list-decl ()
  "Generate the declarations for the static enum-objects representing
   all our values" 
  ;; static-decls is the main C++ code that declares the objects.
  ;; When done, it's a list of strings.  Then we set col to be the
  ;; longest of the strings + 1, which is the column where comments
  ;; will go, if any.  Comments are pretty-printed by aligning them
  ;; vertically.  This is done in the flatten-list-to-string section,
  ;; by invoking the append-comment function on each line (now that we
  ;; know the max length of all of them) and pass it the comment,
  ;; which is only appened if not nil.
  (let* ((klass (%% eg-class-name))
         (static-decls
           (mapcar (lambda (name)
                     (concatenate 'string 
                                  (newline) 
                                  "  static " klass " const " name ";"))
                   (%% enum-primary-names)))
         (col (1+ (maxlen static-decls))))
    (flatten-list-to-string
     (mapcar (lambda (decl comment)
               (append-comment decl col comment))
             static-decls
             (%% enum-comments))
     (newline))))
        

(defexpand enum-obj-list-definition ()
  "Generate the static definitions for the enum-objects representing
   all our values"
  (let ((klass (%% eg-class-name)))
    (flatten-list-to-string
     (mapcar (lambda (name symbol)
               (concatenate 'string 
                            klass " const "
                            klass "::" name 
                            "(" klass "::raw::" symbol ");" (newline)))
             (%% enum-primary-names)
             (%% enum-symbols))
     )))

  
(defexpand enum-default-value ()
  "returns the value assigned to default-constructed enum-objects"
  (let ((defaults ; list all enums with :default set
         (mappend (lambda (enum-info)
                    (a/when2 _ (keyword-lookup-single 
                                :default enum-info 'optional)
                      (list (enumerator-name enum-info))))
                  (%% enumerators))))
    (cond ((null defaults)        (%% enum-invalid-value))
          ((null (cdr defaults))  (car defaults))
          (t (error 
              (format 
               nil 
               "Only one default enumerator allowed: supplied ~A"
               (mapcar #'enumerator-name defaults)))))))

(defexpand enum-invalid-value()
  "returns the (raw) enum name representing the invalid value"
  "INVALID_")

(defun invalid-value-p (sym)
  (string= (%% enum-invalid-value) sym))

(defexpand string-type-include ()
  "#include <string>")

(defexpand string-type ()
  "std::string")

(defexpand string-type-arg ()
  "std::string const &")

(defexpand nvpair-typename ()
  (format nil "~A_nvpair" (%% eg-class-name)))

(defexpand nv-name-less-decl-helper (compare-expr)

  (concatenate 'string 
"struct nv_name_less 
{
  // name type (first) is a "(%% string-type)"
  bool operator()(
      "(%% nvpair-typename)" const & left,
      "(%% nvpair-typename)" const & right) const
  { 
    return (" (funcall compare-expr "left.first" "right.first")");
  }

  bool operator()(
      "(%% nvpair-typename)" const & left,
      "(%% string-type-arg)" right) const
  {
    return (" (funcall compare-expr "left.first" "right")");
  }
};"))

(defexpand nv-name-less-decl ()
  (%% nv-name-less-decl-helper 
   (lambda (a b)
     (format nil "~A < ~A" a b))))

(defexpand name-equal (name1 name2)
   (format nil "~A == ~A" name1 name2))

(defun setup-char-type ()
  (setf string-type-include "#include <cstring>")
  (setf string-type "char const *")
  (setf string-type-arg "char const *")
  (setf nv-name-less-decl 
        (%% nv-name-less-decl-helper 
         (lambda (a b)
           (format nil "std::strcmp(~A, ~A) < 0" a b))))
  (setf name-equal (lambda (name1 name2)
        (format nil "(std::strcmp(~A, ~A) == 0)" name1 name2)))

  "")

(defexpand namespace-decl-open ()
  "declare namespaces and opening curly-braces.  Code following is in
  the innermost namespace."
  ;;format deciphered: 
  ;; [iterate ns list, "namespace <NS> {"] [newline]
  (format nil "~{namespace ~A~%{~%~}" (?? namespace nil)))

(defexpand namespace-decl-close ()
  "close the namespaces. Code following is in the global namespace."
  ;;format deciphered: 
  ;; [iterate ns list, "} // namespace <NS>][newline]
  (format nil "~{} // namespace ~A~%~}" (reverse (?? namespace nil))))

(defexpand qualified-inner-namespace ()
  "produces a single string consising of full namespace
  qualification, up to the innermost namespace name.  
  For example \"A::B::C\""
  (let ((ns (?? namespace nil)))
    (if (null ns)
        ""
        (format nil "~{~A~#[~:;::~]~}" ns))))

(defexpand using-qualified-namespace-opt()
  "returns a using namespace X::Y::Z if the enum class is in a
  namespace (of any depth > 0).  If no namespace, returns an empty
  string"
  (let ((ns (?? namespace nil)))
    (if ns
        (format nil "using namespace ~A;" 
                (%% qualified-inner-namespace))
      "")))

     
(defexpand header-guard-begin ()
  (let ((guard-name 
         (concatenate 'string
                      (join-to-string (?? namespace nil) "__")
                      (context-lookup :filename-prefix 
                                      *cur-section-context*)
                      (context-lookup :filename-base 
                                      *cur-section-context*)
                      (context-lookup :filename-suffix 
                                      *cur-section-context*)
                      "__"
                      (context-lookup :filename-extension
                                      *cur-section-context*)
                      "_")))
    (setf (gethash :header-guard *cur-section-context*) guard-name)

    (format nil "#ifndef ~A~%#define ~A~%"
            guard-name
            guard-name)))

(defexpand header-guard-end ()
  (format nil "#endif // ~A~%" (context-lookup :header-guard  *cur-section-context*)))


(defun get-section (section)
  (let ((sec-info (find section *eg-sections*
                        :test #'(lambda (key sec)
                                  (string= key (section-name sec))))))
    (unless sec-info 
      (error "no section ~A exists" section))
    sec-info))

(defexpand section-filename-ext (section)
    (section-extension (get-section section)))

(defexpand normalized-include-path ()
  (with-output-to-string (outstr)
    (let ((include-path (to-item (?? include-path))))
      ;; paste include path if it exists
      (when (stringp include-path)       
        (format outstr "~A" include-path)
        ;; also paste slash if include-path doesn't end with one
        (let ((include-length (length include-path)))
          (when (and (> include-length 0)
                     (not (eq (char include-path 
                               (1- include-length))
                              #\/)))
            (format outstr "/")))))))


(defexpand section-base-filepath-sans-ext (section)
  "return the base filename without path and without extension"
  (let* ((info (get-section section))
         (context (section-context info))
         (prefix (gethash :filename-prefix context))
         (base   (gethash :filename-base context))
         (suffix (gethash :filename-suffix context)))
    (format nil "~@[~A~]~A~@[~A~]" prefix base suffix)))

(defexpand section-filepath (section)
  "Build the path/filename string for the given section, with extension"
  ;;format deciphered: 
  ;;[opt-path][opt-prefix][base][opt-suffix].[extension]
  (format nil "~@[~A~]~A.~A"
          (?? normalized-include-path)
          (%% section-base-filepath-sans-ext section)
          (%% section-filename-ext section)))
  
(defexpand include-file-for-section (section)
  (format nil "#include \"~A\"" (%% section-filepath section)))


(defexpand all-values-unique ()
  (not (has-duplicates-p (%% enum-values-full))))


(defexpand aliases-to-names (aliases-list names-list)
  "takes a list of list-of-aliases, and a list of names.  For each
  pair of elements from each list, matches all non-nil aliases with
  corresponding name.  Builds a list of these pairwise lists.
  Example:
    input: aliases-list: '((a b c) nil (d e)) 
           names-list  : '(x y z)
    output:
           ((A X) (B X) (C X) (D Z) (E Z))"
  (mappend (lambda (aliases name) 
             (when aliases 
               (mapcar (lambda (alias) (list alias name))
                       aliases)))
           aliases-list
           names-list))

(defexpand sorted-nv-tuple ()
  "returns a sorted list of (string-name name) pairs, for every
  primary-name and alias that exists across all enumerators."
  (let ((aliases (%% enum-aliases))
        (names (%% enum-primary-names)))
    (sort (nconc (mapcar #'list names names)
                 (%% aliases-to-names aliases names))
          (lambda (x y) (string< (car x) (car y))))))
                 
(defexpand nvpair-decl ()
  (format nil "typedef std::pair<~A,~A> ~A;"
                 (%% string-type)
                 (%% eg-class-name)
                 (%% nvpair-typename)))

(defexpand name->value-array-initializer ()
  (let* ((klass (%% eg-class-name))
         (nv-pairs (%% sorted-nv-tuple))
         (remain (length nv-pairs)))
    (with-output-to-string (output)
      (dolist (x nv-pairs)
        (let ((name (first x))
              (value (second x)))
          (decf remain)
          ;; format code decyphered:
          ;; { <name-string>, <value>}[opt-comma if remain > 0]
          (format output "std::make_pair(\"~A\",~A::~A)~[~:;,~]~%  " 
                  name 
                  klass
                  value
                  remain))))))


(defexpand primary-name-array-initializer()
  ;; comma-seperated quoted-string list printer
  (format nil "~{  \"~A\"~#[~:;,~]~%~}" (%% enum-primary-names)))


(defexpand symbols-for-unique-values-array-initializer()
  (flatten-list-to-string
   (mapcar #'(lambda (sym)
               ;; indent 4:  <class>::<symbol>
               (format nil "~4T~A::raw::~A"
                       (%% eg-class-name)
                       sym))
           (%% enum-symbols-for-unique-values))
   ",~%")) ; seperator (comma-newline)


(defexpand name-to-value-map()
  "this generates the body of a name->value function, where the
  enumerators are known to all be unique values.  var-name is how
  to spell the argument"
  (format nil "static ~A ~A_name_value_map[] = {~% ~A};"
                 (%% nvpair-typename)
                 (%% eg-class-name)
                 (%% name-to-value-array-initializer)))

;; =========================================================


(defexpand invalid-value-index ()
  (let ((idx 0))
    (dolist (e (%% enum-symbols))
      (if (string= e (%% enum-invalid-value))
          (return idx)
          (incf idx)))))

(defexpand index-switch-cases (case-body-func)
  (let* ((klass (%% eg-class-name))
         (nvpair-list (%% build-nodupe-nvpair-list :include-invalid))
         (len (1- (length nvpair-list)))
         (idx 0))
    (with-output-to-string 
      (output)
      (when (< (length nvpair-list) (length (%% enum-symbols)))
        (format output 
          "~4T// NOTE: Some enumerators suppressed due to dup. values~%"))

      (mapc (lambda (sym-val)       
              (format output 
                      ;; <indent 4> case <class>::raw::<sym>: <body><opt-NL>
                      "~4Tcase ~A::raw::~A: ~A~A" 
                      klass
                      (car sym-val)
                      (funcall case-body-func idx)
                      (if (< idx len) (newline) ""))
              (incf idx))
            nvpair-list))))


(defstruct alias-info
  names ; aliases
  value ; numeric value
  symbol; enumerator's symbol
)


(defexpand enum-aliases-merged ()
  "returns a list of aliases, just like (%% enum-aliases) but when
  enumerators have the same numeric value, we merge all the aliases
  together."
  ;; merging is done since we could have the following situation:
  ;; enumerator X has aliases ("a" "b" "c"), value = 1
  ;; enumerator Y has aliases ("x" "y" "z"), value = 1
  ;; since X and Y are the same value, then all aliases for either
  ;; should result in the same value, and so all aliases are merged
  ;; from Y into X.  That way they're grouped together when iterating
  ;; over X's (or Y's) aliases.
  ;;
  ;;Thus, after the merge, we only have X with "a" "b" "c" "x" "y" "z")
  ;;
  ;; (NOTE: Y is not an alias for X, because it's still an actual
  ;; enumerator, albeit one with a duplicated value.  We could go
  ;; either way on this, since the behavior is equivalent, but it's
  ;; closer to what the user's input said, and thus (IMHO) less
  ;; confusing.) 
  (let ((known-values (make-hash-table))
        (retval '()))
    (mapc (lambda (sym aliases value)
            (a/if2 names (gethash value known-values)
                   ;; [then] this value is already known, so append
                   ;; our current aliases into the entry already there
                   (nconc names (copy-list aliases))
                   ;; [else] This is a new element.  Add to list, then
                   ;; store the names member in the hash.
                   (let ((newinfo (make-alias-info 
                                   :names (copy-list aliases) 
                                   :value value
                                   :symbol sym)))
                     (push newinfo retval)
                     (setf (gethash value known-values)
                           (alias-info-names newinfo)))))
          (%% enum-symbols)
          (%% enum-aliases)
          (%% enum-values-full))
    (nreverse retval)))

(defun alias-names (&optional (alias-infos (%% enum-aliases-merged)))
  "convert the list of alias-infos into just a list of the alias-list
  entries inside those infos"
  (mapcar #'alias-info-names alias-infos))


(defexpand aliased-name-array-initializer()
  ;; generate a single array initializer holding all aliases.
  ;; comma-seperated quoted-string list printer
  (format nil "~{  \"~A\"~#[~:;,~]~%~}" 
                 (apply #'append (alias-names))))


(defun begin-alias-offsets (aliases-list)
  "return a list of offsets corresponding to the beginning of each
  alias group.  These will correspond to the array initialized by the
  aliased-name-array-initializer function's output"
  (let ((prev 0))
    (mapcar (lambda (aliases)
              (prog1
                  prev
                (setf prev (+ prev (length aliases)))))
            aliases-list)))

(defun end-alias-offsets (aliases-list)
  "return a list of offsets corresponding to the beginning of each
  alias group.  These will correspond to the array initialized by the
  aliased-name-array-initializer function's output"
  (let ((prev 0))
    (mapcar (lambda (aliases)
              (setf prev (+ prev (length aliases))))
            aliases-list)))


(defexpand alias-case-statements (offsets)
  (let ((klass (%% eg-class-name))
        (alias-infos (%% enum-aliases-merged)))
    (flatten-list-to-string
      (mapcar (lambda (info offset)
                (format 
                 nil
                 "~4Tcase ~A::raw::~A: return detail::aliases_ary + ~A;" 
                 klass
                 (alias-info-symbol info)
                 offset))
              alias-infos
              offsets)
      (newline))))

(defexpand alias-begin-case-statements ()
  (%% alias-case-statements
   (begin-alias-offsets (alias-names))))



(defexpand alias-end-case-statements ()
  (%% alias-case-statements
      (end-alias-offsets (alias-names))))


(defexpand validation-case-statements (varname)
  (let ((syms (mapcar #'car
                      (remove-if (lambda (x) (invalid-value-p (car x)))
                                 (%% build-nodupe-nvpair-list))))
        (klass (%% eg-class-name))
        (invalid (%% enum-invalid-value)))
    (flatten-list-to-string
     (append (mapcar (lambda (sym)
                       (format nil "~4Tcase ~A::raw::~A:~%" klass sym))
                     syms)
             (list
              (format nil "~6Tvalue_ = ~A;~%~6Tbreak;~%" varname)
              (format nil 
                      "~%~4Tdefault:~%~6Tvalue_ =  ~A::raw::~A;~%~6Tbreak;"
                      klass invalid))))))
     

(defexpand compatibility-decl ()
  (if *compatibility-interface*
      (flatten-list-to-string (list "
  // COMPATIBILITY INTERFACE 
  static " (%% eg-class-name) 
  " value_from_name(" (%% string-type-arg) " str);
          
  // COMPATIBILITY INTERFACE 
  static " (%% string-type-arg) 
  " name_from_value(" (%% eg-class-name) " val);

  // COMPATIBILITY INTERFACE 
  // set the internal value from the given val.
  void force_value(long val);


"))
      ;; else // COMPATIBILITY INTERFACE
      ""))

(defexpand compatibility-definitions ()
  (if *compatibility-interface*
      (flatten-list-to-string (list "
// COMPATIBILITY INTERFACE 
inline " (%% eg-class-name)"
"(%% eg-class-name)"::
value_from_name(" (%% string-type-arg) " str)
{ 
  return name_to_value(str);
}
         
// COMPATIBILITY INTERFACE 
inline " (%% string-type-arg)"
"(%% eg-class-name) "::
name_from_value(" (%% eg-class-name) " val)
{
  return value_to_name(val);
}
         
// COMPATIBILITY INTERFACE 
inline void
"(%% eg-class-name) "::
force_value(long val)
{
  set_value(val);
}


"))

      ;; else (COMPATIBILITY INTERFACE)
      ""))


